home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
BBS Toolkit
/
BBS Toolkit.iso
/
doors_1
/
doordr50.zip
/
JUNGLE.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-02-02
|
12KB
|
487 lines
uses doordriv,crt,ddscott;
{ EXAMPLE DOOR: The Jungle! }
{ By Scott Baker }
{ }
{ One of my friends wanted me to whip this thing up, but I never }
{ finished it. So here it is! Basically, this door operates as a type }
{ of "Never Ending Story". Users continually add on to the end of a }
{ large "tablet" which contains all of the dialog. }
{ The program is not quite finished - there are some maintenance }
{ options that are really necessary (such as purging the table of old }
{ data), but there isn't much work left. }
{ Also, if you do use any of this code in your own program, I }
{ that you credit my name. }
{$V-}
const
numusers=100;
type
setuprec=record
numstr: word;
minwords,
maxwords,
minpunct,
maxpunct,
mincaps,
maxcaps,
minpro,
maxpro: word;
minpass: word;
end;
userrec=record
realname: string[35];
alias: string[35];
scrsize: word;
totalcaps: longint;
totalpunct: longint;
totalpro: longint;
totalwords: longint;
totallines: longint;
totalposts: longint;
end;
const
setup: setuprec= (numstr: 5000;
minwords: 3;
maxwords: 10;
minpunct: 1;
maxpunct: 10;
mincaps: 2;
maxcaps: 20;
minpro: 0;
maxpro: 3;
minpass: 3);
type
sttypetype=(Authorident,thetext);
strrec=record
sttype: sttypetype;
numlines: word;
str: string[80];
end;
var
strfile: file of strrec; {File to hold the tablet }
header: strrec; {"header" for the tablet }
numuserlines: word; {Number of lines user has typed in}
userlines: array[1..500] of string[80]; {Holds users typing for session }
user: userrec; {Current user record }
userfile: file of userrec; {File to hold user records }
usernum: word; {Record number of user }
exitsave: pointer; {for exit procedure }
procedure AddStr(s: string);
var
st:strrec;
begin;
inc(header.numlines);
st.sttype:=thetext;
st.str:=s;
seek(strfile,header.numlines);
write(strfile,st);
end;
procedure openfiles;
var
s: strrec;
a: integer;
begin;
assign(strfile,'TEXT.DAT');
{$I-}
reset(strfile);
{$I+}
if ioresult<>0 then begin;
rewrite(strfile);
header.sttype:=authorident;
header.str:='';
header.numlines:=1;
s.sttype:=authorident;
s.str:='Introduction';
for a:=1 to setup.numstr do write(strfile,s);
reset(strfile);
Addstr('Welcome to ... The Jungle!');
Addstr('(c) 1991 Scott Baker & Michael Crosson.');
addstr('');
addstr('The world''s best free-format message system! Where it doesn''t matter how');
addstr('you post, where you post, just that you post! ');
seek(strfile,0);
write(strfile,header);
end;
reset(strfile);
read(strfile,header);
assign(userfile,'JNGLUSER.DAT');
{$I-}
reset(userfile);
{$I+}
if ioresult<>0 then begin;
rewrite(userfile);
fillchar(user,sizeof(user),0);
for a:=1 to numusers+1 do write(userfile,user);
end;
reset(userfile);
end;
{$F+}
procedure myexit;
begin;
if usernum<>0 then begin;
seek(userfile,usernum);
write(userfile,user);
end;
close(userfile);
close(strfile);
exitproc:=exitsave;
end;
{$F-}
procedure login;
var
a,b,c: integer;
u: userrec;
s: string;
begin;
swriteln('Welcome to The Jungle!');
swriteln('');
swriteln('Standby, finding your place in the jungle!');
b:=0;
c:=0;
for a:=1 to numusers do begin;
seek(userfile,a);
read(userfile,u);
if u.realname=stu(user_first_name+' '+user_last_name) then b:=a;
if (u.realname='') and (c=0) then c:=a;
end;
swriteln('');
if (b=0) and (c=0) then begin;
swriteln('Sorry, the jungle is kind of crowded right now. Maybe some other time!');
halt;
end;
usernum:=b;
if (b=0) then begin;
usernum:=c;
fillchar(user,sizeof(user),0);
user.realname:=stu(user_first_name+' '+user_last_name);
swriteln('Looks like this is your first visit to the jungle! First, let me ask you');
swriteln('a few questions....');
swriteln('');
repeat;
swrite('What would you like as an alias? ');
sread(user.alias);
swrite(namestr(user.alias)+', Correct (Y/N) ? ');
sread_char(ch);
ch:=upcase(ch);
until ch='Y';
swriteln('');
repeat;
swrite('How many screen lines do you have (15-50) ? ');
sread(s);
val(s,user.scrsize,a);
swrite(wva(user.scrsize)+', Right (Y/N) ? ');
sread_char(ch);
ch:=upcase(ch);
until ch='Y';
swriteln('');
end;
end;
procedure ListFrom(n: word);
var
a: integer;
s: strrec;
s2,s3: string;
begin;
if n>header.numlines then n:=header.numlines;
for a:=n to header.numlines do begin;
seek(strfile,a);
read(strfile,s);
if s.sttype=authorident then begin;
swriteln('');
set_Foreground(lightgray);
set_background(1);
s3:='|||||||||||||||||||||||';
s2:=' Line: '+wva(a)+' ';
move(s2[1],s3[8],length(s2));
swrite(s3);
set_background(0);
swriteln('');
swriteln('');
end else begin;
set_foreground(lightgray);
swriteln(s.str);
end;
end;
end;
procedure adduser(s: string);
begin;
inc(numuserlines);
userlines[numuserlines]:=s;
end;
procedure listuser;
var
a: integer;
begin;
set_foreground(lightred);
swriteln('Your Text:');
set_foreground(white);
for a:=1 to numuserlines do swriteln(userlines[a]);
end;
procedure DispBar(s: string; min,max,v: word; var pass: word);
var
a: integer;
s2: string;
begin;
set_foreground(cyan);
swrite(s);
set_foreground(white);
str(v:3,s2);
swrite(s2+' ');
for a:=0 to 30 do begin;
if a<=v then set_background(cyan) else set_background(blue);
if a=min then begin;
set_foreground(lightred);
swrite('|');
end else if a=max then begin;
set_foreground(lightred);
swrite('|');
end else swrite(' ');
end;
set_foreground(7);
set_background(0);
swrite(' ');
if (v>=min) and (v<=max) then begin;
set_Foreground(0);
set_background(green);
swrite('[PASS]');
inc(pass);
end else begin;
set_foreground(0);
set_background(red);
swrite('[FAIL]');
end;
set_foreground(7);
set_background(0);
swriteln('');
end;
procedure DoBars(lines,words,punct,caps,pro: longint; var pass: word);
begin;
pass:=0;
DispBar('Words Per Line : ',setup.minwords,setup.maxwords,words div lines,pass);
swriteln('');
DispBar('Punctuation Per Line : ',setup.minpunct,setup.maxpunct,punct div lines,pass);
swriteln('');
dispbar('Capitol Letters Per Line: ',setup.mincaps,setup.maxcaps,caps div lines,pass);
swriteln('');
dispbar('Profanity : ',setup.minpro,setup.maxpro,pro div lines,pass);
end;
procedure checkusertext;
const
pchars= [':'..'@','['..'`','!'..'/'];
var
caps: word;
words: word;
punct: word;
pro: word;
found: boolean;
a,b: integer;
lastspace: boolean;
pros: array[1..255] of string[30];
numpros: word;
s2: string;
f: text;
pass: word;
begin;
if numuserlines=0 then exit;
sclrscr;
set_foreground(lightgray);
swriteln('Standby, Testing your text for content:');
swriteln('');
if exist('JUNGBAD.TXT') then begin;
assign(f,'JUNGBAD.TXT');
reset(f);
numpros:=0;
while not eof(F) do begin;
inc(numpros);
readln(f,pros[numpros]);
if length(pros[numpros])<2 then dec(numpros);
end;
close(F);
end else numpros:=0;
caps:=0;
words:=0;
punct:=0;
pro:=0;
for a:=1 to numuserlines do begin;
inc(words);
lastspace:=true;
swrite(#13+'Line: '+wva(a));
delay(125);
for b:=1 to length(userlines[a]) do begin;
if userlines[a][b] in pchars then inc(punct);
if userlines[a][b] in ['A'..'Z'] then inc(caps);
if (userlines[a][b] in pchars) or (userlines[a][b] = ' ') then begin;
if not lastspace then inc(words);
lastspace:=true;
end else lastspace:=false;
end;
s2:=userlines[a];
repeat;
found:=false;
for b:=1 to numpros do if pos(stu(pros[b]),stu(s2))<>0 then begin;
found:=true;
inc(pro);
delete(s2,pos(stu(pros[b]),stu(s2)),length(pros[b]));
end;
until found=false;
end;
while wherex>1 do swrite(#8' '#8);
set_foreground(7);
set_background(1);
swrite('[-- User text analysis --]');
set_foreground(7);
set_Background(0);
swriteln('');
swriteln('');
dobars(numuserlines,words,punct,caps,pro,pass);
swriteln('');
if pass<setup.minpass then begin;
set_Foreground(lightred);
swriteln('You did not pass enough tests! Your writing has been discarded!');
numuserlines:=0;
end else begin;
set_Foreground(lightgreen);
swriteln('You passed! Your writing is saved.');
user.totalwords:=user.totalwords+words;
user.totalpunct:=user.totalpunct+punct;
user.totalcaps:=user.totalcaps+caps;
user.totalpro:=user.totalpro+pro;
user.totallines:=user.totallines+numuserlines;
end;
end;
procedure ShowHistory;
var
pass: word;
begin;
swriteln('');
swriteln('Your posting history:');
swriteln('');
if user.totallines=0 then begin;
swriteln('You have no posting history!');
exit;
end;
dobars(user.totallines,user.totalwords,user.totalpunct,user.totalcaps,user.totalpro,pass);
end;
procedure wreadln(var thestr,wwrap: string);
var
s,s2: string[162];
a,b,c: integer;
ch: char;
done: boolean;
begin;
done:=false;
if thestr<>'' then swrite(thestr);
wwrap:='';
repeat;
sread_char(ch);
if (ch=#8) and (length(thestr)>0) then begin;
swrite(#8+' '+#8);
delete(thestr,length(thestr),1);
end;
if not (ch in [#$0d,#$08]) then begin;
thestr:=thestr+ch;
swrite(ch);
end;
if length(thestr)>72 then begin;
c:=0;
for b:=1 to length(thestr) do if thestr[b]=' ' then c:=b;
s:='';
if c>60 then begin;
for b:=c+1 to length(thestr) do begin;
s:=s+thestr[b];
swrite(#8+' '+#8);
end;
for b:=c to length(thestr) do delete(thestr,length(thestr),1);
end;
wwrap:=s;
done:=true;
end;
until (ch=#13) or (done);
swriteln('');
end;
procedure mainloop;
var
s: string;
a,b: integer;
done: boolean;
wwrap: string;
begin;
done:=false;
wwrap:='';
repeat;
set_foreground(lightcyan);
swrite('> ');
set_foreground(white);
s:=wwrap;
wreadln(s,wwrap);
set_foreground(lightgray);
if stu(s)='H' then showhistory;
val(s,a,b);
if a<>0 then begin;
listfrom(a);
swriteln('');
listuser;
swriteln('');
end else if (stu(s)='Q') or (stu(s)='O') or (stu(s)='QUIT') or (stu(s)='EXIT') then begin;
done:=true;
end else if stu(s)<>'H' then adduser(s);
until done;
checkusertext;
end;
procedure savefiles;
var
a: integer;
s: strrec;
begin;
if numuserlines<>0 then begin;
s.sttype:=authorident;
s.str:=stu(user_first_name+' '+user_last_name);
inc(header.numlines);
seek(strfile,header.numlines);
write(strfile,s);
end;
for a:=1 to numuserlines do addstr(userlines[a]);
seek(strfile,0);
write(strfile,header);
end;
begin;
initdoordriver('DOORDRIV.CTL');
morechk:=false;
progname:='The Jungle!';
numuserlines:=0;
usernum:=0;
openfiles;
exitsave:=exitproc;
exitproc:=@myexit;
login;
mainloop;
savefiles;
delay(1000);
end.